Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/COMPNENT/SAWIN95/TRAYICON.PAS

Pascal/Delphi Source File | 1996-10-22 | 5KB | 188 lines

unit TrayIcon;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Menus,
  WComp, ExtCtrls, ShellAPI;

type
  TTrayIcon = class(TWindowedComponent)
  private
    { property variables }
    FActive      : Boolean;
    FIcon        : TIcon;
    FHint        : String;
    FPopupMenu   : TPopupMenu;
    { event variables }
    FOnClick     : TNotifyEvent;
    FOnDblClick  : TNotifyEvent;
    { internal variables }
    FCallBackMsg : Word;
    FNotifyData  : TNotifyIconData;
    FPreventClick: Boolean;
    FTrayIcon    : hIcon;
    FTimer       : TTimer;
    { Property setting routines }
    procedure SetActive(Value: Boolean);
    procedure SetIcon(Value: TIcon);
    procedure SetHint(Value: String);
    procedure SetPopupMenu(Value: TPopupMenu);
  protected
    { Internal routines }
    procedure ShellNotifyIcon(Msg: DWord; Flags: UInt);
    procedure OnClickTimer(Sender: TObject);
    function  LoadWorldIcon: THandle;
    { Overrides }
    procedure WndProc(var Message: TMessage); override;
    procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
    procedure Loaded; override;
  public
    { Public routines }
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
  published
    { Properties }
    property Active    : Boolean      read FActive     write SetActive default False;
    property Icon      : TIcon        read FIcon       write SetIcon;
    property Hint      : String       read FHint       write SetHint;
    property PopupMenu : TPopupMenu   read FPopupMenu  write FPopupMenu;
    { Events }
    property OnClick   : TNotifyEvent read FOnClick    write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
  end;

{$R TRAYICON.RES}

implementation

{ TTrayIcon }

constructor TTrayIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCallbackMsg := RegisterWindowMessage('TTrayIconCallBackMsg');
  FIcon := TIcon.Create;
  FIcon.Handle := LoadWorldIcon;
  FTimer := TTimer.Create(Self);
  with FTimer do begin
    Enabled := False;
    Interval := GetDoubleClickTime;
    OnTimer := OnClickTimer;
  end;
end;

destructor TTrayIcon.Destroy;
begin
  Active := False;
  FIcon.Free;
  FTimer.Free;
  inherited Destroy;
end;

procedure TTrayIcon.Loaded;
begin
  inherited Loaded;
  if Active then ShellNotifyIcon(NIM_ADD, NIF_MESSAGE or NIF_ICON or NIF_TIP);
end;

procedure TTrayIcon.WndProc(var Message: TMessage);
var
  Point: TPoint;
begin
  with Message do
   begin
     if (Msg = FCallBackMsg) and (wParam = 0) then
      begin
        case lParam of

          wm_LButtonDown   : FTimer.Enabled := True;
          wm_LButtonDblClk :
           begin
             FPreventClick := True;
             if Assigned(OnDblClick) then OnDblClick(Self);
           end;
          wm_RButtonDown   :
           begin
             if Assigned(PopupMenu) then
              begin
                SetForeGroundWindow((Owner As TForm).Handle);
                GetCursorPos(Point);
                PopupMenu.Popup(Point.X, Point.Y);
                PostMessage((Owner As TForm).Handle, WM_USER, 0, 0);
              end;
           end;
        end;
      end
     else
      inherited;
   end;
end;

procedure TTrayIcon.SetActive(Value: Boolean);
const
  Values: array[Boolean] of DWord = (NIM_DELETE, NIM_ADD);
begin
  if FActive <> Value then
   begin
     FActive := Value;
     ShellNotifyIcon(Values[Active], NIF_MESSAGE or NIF_ICON or NIF_TIP);
   end;
end;

procedure TTrayIcon.SetHint(Value : String);
begin
  if FHint <> Value then
   begin
     FHint := Value;
     if Active then ShellNotifyIcon(NIM_MODIFY, NIF_TIP);
   end;
end;

procedure TTrayIcon.SetIcon(Value: TIcon);
begin
  FIcon.Assign(Value);
  if FIcon.Empty then FIcon.Handle := LoadWorldIcon;
  if Active then ShellNotifyIcon(NIM_MODIFY, NIF_ICON);
end;

procedure TTrayIcon.SetPopupMenu(Value: TPopupMenu);
begin
  FPopupMenu := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TTrayIcon.Notification(AComponent: TComponent; AOperation: TOperation);
begin
  inherited Notification(AComponent, AOperation);
  if (AComponent = PopupMenu) and (AOperation = opRemove) then PopupMenu := nil;
end;

procedure TTrayIcon.OnClickTimer(Sender: TObject);
begin
  FTimer.Enabled := False;
  if (not FPreventClick) and Assigned(OnClick) then OnClick(Self);
  FPreventClick := False;
end;

function TTrayIcon.LoadWorldIcon: THandle;
begin
  Result := LoadImage(hInstance, 'TRAYICON', IMAGE_ICON, 16, 16, LR_LOADREALSIZE);
end;

procedure TTrayIcon.ShellNotifyIcon(Msg: DWord; Flags: UInt);
begin
  with FNotifyData do begin
    cbSize := SizeOf(FNotifyData);
    StrPLCopy(szTip, PChar(Hint), SizeOf(szTip));
    uFlags := Flags;
    uID := 0;
    Wnd := Handle;
    uCallbackMessage := FCallBackMsg;
    hIcon  := FIcon.Handle;
  end;
  Shell_NotifyIcon(Msg, @FNotifyData);
end;

end.